home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1996 #14 / Monster Media No. 14 (April 1996) (Monster Media, Inc.).ISO / netmail / txtq130.zip / SLMRQ.PAS < prev    next >
Pascal/Delphi Source File  |  1996-01-26  |  8KB  |  242 lines
  1. {$M 10240,0,655360}  { 10k reserved for data }
  2. {$N-,E- no math support needed}
  3. {$X- function calls may not be discarded}
  4. {$I- disable I/O checking (trap errors by checking IOResult)}
  5.  
  6. PROGRAM Convert_SLMR_SAV_files_to_QWK;
  7. USES
  8.   DOS,
  9.   TXTQ;
  10. VAR
  11.   SavedExitProc: POINTER;
  12.  
  13. {===========================================================================}
  14.  
  15. PROCEDURE CustomExit; FAR;
  16. {---- Always exit through here ----}
  17. BEGIN
  18.   ExitProc := SavedExitProc;
  19.   cursorOn;
  20.   Cleanup;
  21.   IF (ExitCode > 0) THEN BEGIN
  22.     WriteLn;
  23.     WriteLn ('SLMRQ - Free DOS utility: Convert SLMR .SAV text files to QWK files.');
  24.     WriteLn (author);
  25.     WriteLn;
  26.     WriteLn ('Usage:  SLMRQ <SLMR .SAV file(s)>         (DOS wildcards are permitted.)');
  27.     WriteLn;
  28.     WriteLn ('Example:  SLMRQ startrek.sav              (creates "STARTREK.Q??")');
  29.     WriteLn;
  30.   END;
  31.   IF ErrorAddr <> NIL THEN
  32.   BEGIN
  33.     WriteLn ('An unanticipated error occurred, please contact DDA with the following data:');
  34.     WriteLn ('Address = ', Seg (ErrorAddr^), ':', Ofs (ErrorAddr^));
  35.     WriteLn ('Code    = ', ExitCode);
  36.     ErrorAddr := NIL;
  37.   END
  38.   ELSE
  39.     IF (ExitCode > 0) AND (ExitCode < 255) THEN
  40.       WriteErr (ExitCode);
  41. END;
  42.  
  43. FUNCTION GetParenNum (tStr: STRING): STRING;
  44. CONST
  45.   LParen = '(';
  46.   RParen = ')';
  47. BEGIN
  48.   IF (Pos (LParen, tStr) > 0) THEN
  49.     Delete (tStr, 1, Pos (LParen, tStr));
  50.   IF (Pos (RParen, tStr) > 0) THEN
  51.     tStr := Copy (tStr, 1, Pos (RParen, tStr) - 1);
  52.   GetParenNum := tStr;
  53. END;
  54.  
  55. FUNCTION GetMsgStat (CONST Status: STRING): CHAR;
  56. (* Note: the meaning of the status flag in the header of the QWK format
  57.          specification is interpreted differently by different products.
  58.  
  59.    According to Patrick Y. Lee's "QWK Mail Packet File Layout" v1.0
  60.    and Robomail v1.30, an asterisk ('*') means private and received,
  61.                  and the plus sign ('+') means private and NOT received.
  62.  
  63.    SLMR, OLX, and SPEED seem to agree that the meaning of the two
  64.    symbols is reversed.
  65.  
  66.    Since this is a SLMR utility, I've used the latter.  Thus, the private
  67.    and received flags will be translated into the following symbols:
  68.  
  69.               public, unread   =  ' '  (#32)
  70.               public, read     =  '-'  (#45)
  71.               private, unread  =  '*'  (#42)
  72.               private, read    =  '+'  (#43)
  73. *)
  74. CONST
  75.   Priv = '(PVT)';
  76.   YES = 'YES';
  77.  
  78. VAR MsgStat: CHAR;
  79.  
  80. BEGIN
  81.   IF (Pos (Priv, Status) > 0) 
  82.    THEN
  83.     IF (Pos (YES, Status) > 0)
  84.      THEN MsgStat := #43   { private, read }
  85.      ELSE MsgStat := #42   { private, unread }
  86.    ELSE
  87.     IF (Pos (YES, Status) > 0)
  88.      THEN MsgStat := #45   { public, read }
  89.      ELSE MsgStat := #32;  { public, unread }
  90.  
  91.   GetMsgStat := MsgStat;
  92. END;
  93.  
  94. FUNCTION GetConfName (ConfName: STRING): STRING;
  95. BEGIN
  96.   IF (Pos (')', ConfName) <> 0)
  97.    THEN GetConfName := Trim (Copy (ConfName, 2 + Pos (')', ConfName), Length (ConfName)))
  98.    ELSE GetConfName := 'Unknown'
  99. END;
  100.  
  101. FUNCTION ReadMsgheader (VAR Msgfile: FILE): STRING;
  102. CONST
  103.   hyphens = '-------------------------------------' +
  104.             '--------------------------------------';
  105.   Msgpass = #32#32#32#32#32#32#32#32#32#32#32#32; { 12 spaces }
  106.   Msgchnk = #32#32#32#32#32#32;  { 6 spaces }
  107.  
  108. VAR
  109.   Msgline: STRING;
  110.   Msgfrom, Msgto, Msgsubj: STRING [25];
  111.   Msgdate: STRING [8];  Msgtime: STRING [5];
  112.   Msgnumb: STRING [7];  Msgrfer: STRING [8];
  113.   ConfNum: STRING [5];  MsgStat: CHAR;
  114.  
  115. BEGIN
  116.   ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
  117.   Verify (Msgline, 'BBS:', 2);
  118.  
  119.   IF BBSname = '' THEN
  120.     BBSname := Trim (Copy (Msgline, 7, Length (Msgline)));
  121.  
  122.   ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
  123.   Verify (Msgline, 'Date:',   1); Msgdate := Copy (Msgline, 7, 8);
  124.   Verify (Msgline, '(',      16); Msgtime := Copy (Msgline, 17, 5);
  125.   Verify (Msgline, 'Number:',36); Msgnumb := RPad (Copy (Msgline, 44, Length (Msgline) - 43), 7, #32);
  126.  
  127.   ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
  128.   Verify (Msgline, 'From:',   1); Msgfrom := Copy (Msgline, 7, 25);
  129.   Verify (Msgline, 'Refer#:',36); Msgrfer := RPad (Copy (Msgline, 44, Length (Msgline) - 43), 8, #32);
  130.  
  131.   ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
  132.   Verify (Msgline, 'To:',     3); Msgto := Copy (Msgline, 7, 25);
  133.   Verify (Msgline, 'Recvd:', 37); MsgStat := GetMsgStat (Copy (Msgline, 44, Length (Msgline) - 43));
  134.  
  135.   ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
  136.   Verify (Msgline, 'Subj:',   1); Msgsubj := Copy (Msgline, 7, 25);
  137.   Verify (Msgline, 'Conf:',  38); ConfNum := StrToDoubleChar (GetParenNum (Copy (Msgline, 44, 5)));
  138.  
  139.   AddConfToList (ConfNum, GetConfName (Copy (Msgline, 44, Length (Msgline))));
  140.   AddMsgToList (ConfNum, Blocks);
  141.  
  142.   ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);  {discard hyphen line}
  143.   Verify (Msgline, hyphens, 1);
  144.  
  145.   ReadMsgheader := (MsgStat + Msgnumb + Msgdate+ MsgTime+    {  1+7+8+5 = 21 }
  146.                     Msgto + Msgfrom + Msgsubj +              { 25+25+25 = 75 }
  147.                     Msgpass + Msgrfer + Msgchnk + #225 +     { 12+8+6+1 = 27 }
  148.                     ConfNum + #0#0#42);                      { 2+3      =  5 }
  149. END;
  150.  
  151. {===========================================================================}
  152.  
  153. CONST
  154.   SepLine = '=====================================' +
  155.             '======================================';
  156.  
  157. VAR
  158.   Msgname: PATHSTR;
  159.   Msgext : EXTSTR;
  160.   Msgfile: FILE;     DATfile : FILE;
  161.   Msgline: STRING;   Message : MsgArray;
  162.   index, bytes, chunks: WORD;
  163.   Compressor : PATHSTR;
  164.  
  165.   dirinfo   : SEARCHREC;  { contains filespec info. }
  166.   spath     : PATHSTR;    { source file path and    }
  167.   sdir      : DIRSTR;     {             directory   }
  168.   filesdone : WORD;
  169.  
  170. BEGIN
  171.   SavedExitProc := ExitProc;
  172.   ExitProc := @CustomExit;
  173.  
  174.   IF ParamCount <> 1
  175.     THEN Halt (255)
  176.     ELSE spath := GetFilePath (ParamStr (1), sDir);
  177.  
  178.   FindFirst (spath, Archive, dirinfo);
  179.   filesdone := 0;
  180.  
  181.   MkDir (TXTQ_DIR); CheckIO;
  182.   ChDir (TXTQ_DIR); CheckIO;
  183.  
  184.   WHILE (DosError = 0) DO BEGIN
  185.     BBSname := '';
  186.     ConfList := NIL;
  187.     MsgList := NIL;
  188.     Conferences := 0;
  189.  
  190.     Inc (filesdone);
  191.     Msgname := sdir + dirinfo. Name;
  192.     PrepareFiles (Msgname, Msgext, Msgfile, DATfile);
  193.     Blocks := 0;
  194.     Chunks := 2;
  195.     ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
  196.     REPEAT
  197.       IF (NOT EoF (Msgfile)) AND (Msgline = SepLine) THEN BEGIN
  198.         bytes := 0;  updateCursor;
  199.         Inc (Blocks, chunks);
  200.         Msgline := ReadMsgHeader (Msgfile);
  201.         REPEAT
  202.           IF (bytes < MaxBytes) THEN
  203.             bytes := AddToArray (Message, bytes, Msgline);
  204.           ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
  205.         UNTIL EoF (Msgfile) OR (Msgline = SepLine);
  206.         IF EoF (Msgfile) AND (bytes < MaxBytes) THEN
  207.           bytes := AddToArray (Message, bytes, Msgline);
  208.         IF (bytes > MaxBytes) THEN bytes := MaxBytes;
  209.         WHILE (Message [bytes] = #227) AND (Message [bytes - 1] = #227) DO
  210.           Dec (bytes);
  211.  
  212.         index := AddToArray (Message, 116, FigureMSGsize (bytes, chunks));
  213.         IF (chunks > 1) THEN BEGIN
  214.           FOR index := (bytes + 1) TO (chunks * 128) DO
  215.             Message [index] := #32;
  216.         END;
  217.  
  218.         BlockWrite (DATfile, Message, chunks * 128); CheckIO;
  219.  
  220.       END
  221.       ELSE BEGIN
  222.         ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb); {discard invalid lines}
  223.       END;
  224.     UNTIL EoF (Msgfile);
  225.  
  226.     Close (Msgfile); CheckIO;
  227.     Close (DATfile); CheckIO;
  228.     WriteLn ('done!');
  229.  
  230.     InitConfig (Compressor);
  231.     Write ('Compressing ', DATname, ' into ', Msgname, Msgext, ' ... ');
  232.     IF CompressDat (Msgname + Msgext, Compressor)
  233.       THEN WriteLn ('done!')
  234.       ELSE Halt (5);
  235.  
  236.     FindNext (dirinfo);
  237.   END;
  238.   IF (filesdone = 0)
  239.     THEN Halt (1)
  240.     ELSE WriteLn ('Processed ', filesdone, ' file(s).');
  241. END.
  242.